home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / apps / 25 / applic / dgen.pas next >
Pascal/Delphi Source File  |  1986-06-19  |  6KB  |  258 lines
  1. (*
  2.     Degasgen,  Translate .RLE file into a Degas .PI1 file
  3.  
  4.     FUNCTION:
  5.  
  6.     Degasgen takes a CompuServe Run Length Encoded (.RLE) format
  7.     file and translates it into a DEGAS low resolution (.PI1)
  8.     file suitable for editing with DEGAS.
  9.  
  10.     USAGE:
  11.  
  12.     The program is a .TOS file; it will prompt you for the names
  13.     of two files: an RLE file and then a .PI1 file.  If the .PI1
  14.     file already exists, it will be overwritten.
  15.  
  16.     NOTES:
  17.  
  18.     RLE format files have a resolution of 256 wide by 192 deep. 
  19.     DEGAS .PI1 files have a resolution of 320 wide by 200 deep.  Not
  20.     only that, but they have 16 levels of color per pixel, whereas
  21.     RLE files are strictly black or white.  Thus, you may assume that
  22.     RLE files do not tax the abilities of DEGAS.  On the other hand,
  23.     you can view RLE files on Commodore 64s, Atari 800s, Apples,
  24.     etc.
  25.  
  26.     AUTHOR:
  27.  
  28.     Charles McGuinness, May 1986
  29.  
  30.     MODIFICATIONS:
  31.  
  32.     V1.1    May 27, 1986    Charles McGuinness
  33.  
  34.         o If file ends before ESC G H, don't cause run time error
  35.         o End program with a PRESS RETURN TO CONTINUE
  36.  
  37.     <your name goes here ... don't forget to describe what you did>
  38.  
  39. *)
  40.  
  41. program degasgen;
  42.  
  43. type    timage = array [0..15999] of integer;
  44.  
  45.     tinf = packed file of byte;
  46.  
  47. var    image : ^timage;            (* The Degas Image    *)
  48.  
  49.     inf :  tinf;                (* What we read        *)
  50.     outf : file of integer;            (* What we write    *)
  51.  
  52.     line : string;                (* Throw away string    *)
  53.  
  54.     i : integer;
  55.  
  56.     c : byte;
  57.  
  58.     currow, curcol, black, white, white2 : integer;
  59.  
  60.     sdot : integer;
  61.  
  62. (*    The following two functions are defined by the Personal Pascal    *)
  63. (*    Compiler.                            *)
  64.  
  65. procedure io_check(b:boolean); external;
  66. function io_result: integer; external;
  67.  
  68. (*    SET_PIX:                            *)
  69. (*                                    *)
  70. (*    Sets the specified pixel in the DEGAS image to either black    *)
  71. (*    or white (b=0 means black, b=1 means white).            *)
  72. (*                                    *)
  73. (*    Note that in low resolution mode, each pixel on the ST's    *)
  74. (*    screen is represented by four bits in the screen.  That's    *)
  75. (*    why we go through the fun of all this bit magic.        *)
  76. (*                                    *)
  77. (*    Trust me, it works.                        *)
  78.  
  79. procedure set_pix(x,y,b : integer);
  80. var    normal, offset,u : integer;
  81. begin
  82.  
  83.     offset := (y * 80) + ((x div 16)*4);
  84.  
  85.     normal := 15 - (x & 15);
  86.     u := shl(b,normal);
  87.  
  88.     image^[offset+0] := image^[offset+0] | u;
  89.     image^[offset+1] := image^[offset+1] | u;
  90.     image^[offset+2] := image^[offset+2] | u;
  91.     image^[offset+3] := image^[offset+3] | u;
  92. end;
  93.  
  94. (*    How to exit the program from any point, and do it        *)
  95. (*    so that the user has a chance to see what's gone on        *)
  96. procedure my_halt;
  97. begin
  98.     write('Press RETURN to continue: ');
  99.     readln;
  100.     halt;
  101. end;
  102.  
  103. procedure inc_sdot;
  104. begin
  105.     sdot := sdot + 1;
  106.  
  107.     if ((sdot mod 64) = 0) then begin
  108.         writeln;
  109.         write('<',sdot:5,'>');
  110.         end;
  111.  
  112.     write('.');
  113. end;
  114.  
  115. function fgetc(var f : tinf): integer;
  116. var    t : integer;
  117. begin
  118.     io_check(FALSE);    (* Turn off error checking    *)
  119.     get(f);
  120.     if (0 <> io_result) then    fgetc := -1
  121.     else                 fgetc := (f^) & 127;
  122.     io_check(TRUE);
  123. end;
  124.  
  125. begin    (* MAIN *)
  126.  
  127. writeln('Degas to RLE Conversion program, version 1.1 (May 27, 1986)');
  128. writeln;
  129. writeln('Copyright (C) 1986, Charles McGuinness');
  130. writeln;
  131. writeln('Portions of this product are Copyright (c) 1986, OSS and CCD.');
  132. writeln('Used by Permission of OSS.');    (* Yes, this is personal pascal    *)
  133. writeln;
  134.  
  135.     new(image);
  136.  
  137.     for i:=0 to 15999 do begin
  138.         image^[i] := 0;        (* Set the image to BLACK    *)
  139.         end;
  140.  
  141.     (*    Open the input, output files....            *)
  142.  
  143.     write('Input (.RLE) file:  ');
  144.     readln(line);
  145.  
  146.     IO_Check(FALSE);
  147.  
  148.     reset(inf,line);
  149.  
  150.     i := io_result;
  151.  
  152.     if (i <> 0) then begin
  153.         writeln('I was unable to open ',line);
  154.         my_halt;
  155.         end;
  156.  
  157.     io_check(TRUE);
  158.     write('Output (.PI1) file: ');
  159.     readln(line);
  160.     io_check(FALSE);
  161.     rewrite(outf,line);
  162.     i := io_result;
  163.     io_check(TRUE);
  164.  
  165.     if (i <> 0) then begin
  166.         close(inf);
  167.         writeln('I was unable to create ',line);
  168.         my_halt;
  169.         end;
  170.  
  171.     writeln;
  172.     writeln('Reading input file ...');
  173.  
  174.     repeat
  175.         c := inf^;
  176.         get(inf);
  177.     until (c & 127 = 27);    (* Search for escape    *)
  178.  
  179.     get(inf);        (* Eat the G, leave the H in buffer    *)
  180.  
  181.     curcol := 0;
  182.     currow := 0;
  183.     sdot := 0;
  184.  
  185.     writeln;
  186.     write('<    0>.');
  187.  
  188.     repeat
  189.  
  190.         black :=  fgetc(inf)-32;
  191.  
  192.         if (black >= 0) then
  193.             white := fgetc(inf)-32;
  194.  
  195.         if ((black >= 0) and (white >= 0)) then begin
  196.             curcol := curcol + black;
  197.  
  198.             if (curcol >= 256) then begin
  199.                 inc_sdot;
  200.                 curcol := curcol - 256;
  201.                 currow := currow + 1;
  202.                 end;
  203.  
  204.             repeat
  205.                 white2 := 0;
  206.                 if ((curcol+white) >= 256) then begin
  207.                     inc_sdot;
  208.                     white2 := white+curcol - 256;
  209.                     white  := 256 - curcol;
  210.                     end;
  211.                 if (white <> 0) then
  212.                     for i:= curcol to curcol+white-1 do
  213.                         set_pix(i,currow,1);
  214.                 curcol := curcol + white;
  215.                 if curcol = 256 then begin
  216.                     curcol := 0;
  217.                     currow := currow + 1;
  218.                     end;
  219.                 white := white2;
  220.             until (white = 0);
  221.             end;
  222.     until ((white < 0) or (black < 0));
  223.  
  224.     writeln;
  225.     writeln;
  226.     writeln('Generating output file now ....');
  227.  
  228.     outf^ := 0;
  229.     put(outf);
  230.  
  231.     for i :=0 to 15 do begin
  232.         outf^ := (i div 2) * $111;
  233.         put(outf);
  234.         end;
  235.  
  236.     sdot := 0;
  237.  
  238.     for i := 0 to 15999 do begin
  239.         if ((sdot mod (80*64)) = 0) then begin
  240.             writeln;
  241.             write('<',(sdot div 80):5,'>');
  242.             end;
  243.         if ((sdot mod 80) = 0) then
  244.             write('.');
  245.         sdot := sdot + 1;
  246.         outf^ := image^[i];
  247.         put(outf);
  248.         end;
  249.  
  250.     close(outf);
  251.     close(inf);
  252.     writeln;
  253.     writeln;
  254.     writeln('Conversion Finished.');
  255.     writeln;
  256.     my_halt;
  257. end.
  258. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə